home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / a_to_d / dirscan / dirscan.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1996-09-15  |  4.7 KB  |  122 lines
  1. unit Dirscan;
  2.  
  3. interface
  4.  
  5. Uses SysUtils;
  6. { We need a method to get the files we find inside the directoy scan
  7.   to the place where we can evaluate the names etc., typically
  8.   somewhere near the place in our code where FindRecursive is called.
  9.  
  10.   We use a notification for this. Notifications (aka events) abound
  11.   in Delphi, they are implemented via class methods. FindResource
  12.   takes such a class method as parameter. It has to fit the following
  13.   prototype:
  14. }
  15. Type
  16.   TLogFunct = Function( Const path: String; Const SRec: TSearchRec ): Boolean
  17.                 of Object;
  18.  
  19. { this is the directory scanner }
  20. Procedure FindRecursive( Const path: String; Const mask: String;
  21.                          LogFunction: TLogFunct );
  22.  
  23. implementation
  24.  
  25.  
  26. {+-------------------------------------------------------------
  27.  | Procedure FindRecursive
  28.  | Parameters:
  29.  |   path:  the directory the scan should start in. If this parameter
  30.  |          is an empty string, the current directory will be used.
  31.  |   mask:  the file mask the files we search for should fit. This
  32.  |          mask will normally contain DOS wildcards, like in '*.pas'
  33.  |          to find all Pascal source files.
  34.  |          If this parameter is an empty string, '*.*' is used.
  35.  |   LogFunction:
  36.  |          This has to be a class method of the prototype TLogFunct.
  37.  | Description:
  38.  | The procedure starts at the directory given in path and searches it
  39.  | for files matching the mask. LogFunction will be called for each file
  40.  | we find with the current directory and the search record filled by
  41.  | FindFirst/Next. The path will always end in a backslash,  so
  42.  | path+SRec.Name yields the full name of the found file.
  43.  | If the function returns False, the recursion will stop and
  44.  | FindRecursive returns immediately.
  45.  | After the directory has been scanned for files it is again scanned
  46.  | for directories and each found directory is in turn scanned in the
  47.  | same manner.
  48.  +-------------------------------------------------------------------}
  49. Procedure FindRecursive( Const path: String; Const mask: String;
  50.                          LogFunction: TLogFunct );
  51.   Var
  52.     fullpath: String;
  53.   { Recurse does the work and is called again for every subdirectory
  54.     we find. }
  55.   Function Recurse( Var path: String; Const mask: String ): Boolean;
  56.     Var
  57.       SRec: TSearchRec;
  58.       retval: Integer;
  59.       oldlen: Integer;
  60.     Begin
  61.       { set default return value: continue scan }
  62.       Recurse := True;
  63.  
  64.       { remember current length of path so we can chop off added
  65.         subdirectory names again. path is guaranteed to end in a
  66.         backslash here }
  67.       oldlen := Length( path );
  68.  
  69.       (* phase 1, look for normal files *)
  70.       retval := FindFirst( path+mask, faAnyFile, SRec );
  71.       While retval = 0 Do Begin
  72.         If (SRec.Attr and (faDirectory or faVolumeID)) = 0 Then
  73.           (* we found a file, not a directory or volume label,
  74.              log it. Bail out if the log function returns false. *)
  75.           If not LogFunction( path, SRec ) Then Begin
  76.             Result := False; {causes outer levels of recursion to end, too}
  77.             Break;
  78.           End;
  79.         retval := FindNext( SRec );
  80.       End;
  81.       FindClose( SRec );     { added for Win32 compatibility }
  82.       If not Result Then Exit;
  83.  
  84.       (* Phase II, look for subdirectories and recurse thru them *)
  85.       retval := FindFirst( path+'*.*', faDirectory, SRec );
  86.       While retval = 0 Do Begin
  87.         If (SRec.Attr and faDirectory) <> 0 Then
  88.           (* we have a directory, but do _not_ recurse thru these
  89.              blasted proxy pseudodirectories standing for the
  90.              current dir and its parent. That would cause an infinit
  91.              recursion loop... *)
  92.           If (SRec.Name <> '.') and (SRec.Name <> '..') Then Begin
  93.             { ok, its a harmless dir, add its name to path and recurse }
  94.             path := path + SRec.Name + '\';
  95.             If not Recurse( path, mask ) Then Begin
  96.               Result := False;
  97.               Break;
  98.             End;
  99.             { remove the added name again so we can stick on the next
  100.               on the next round of the While loop }
  101.             Delete( path, oldlen+1, 255 );
  102.           End;
  103.         retval := FindNext( SRec );
  104.       End;
  105.       FindClose( SRec );
  106.     End; { Recurse }
  107.   Begin
  108.     { check parameters, set defaults if empty }
  109.     If path = '' Then
  110.       GetDir(0, fullpath)
  111.     Else
  112.       fullpath := path;
  113.     If fullpath[Length(fullpath)] <> '\' Then
  114.       fullpath := fullpath + '\';
  115.     If mask = '' Then
  116.       Recurse( fullpath, '*.*' )
  117.     Else
  118.       Recurse( fullpath, mask );
  119.   End; { FindRecursive }
  120.  
  121. end.
  122.